home *** CD-ROM | disk | FTP | other *** search
/ Total Network Tools 2002 / NextStepPublishing-TotalNetworkTools2002-Win95.iso / Archive / Web Server / TinyWeb Server.EXE / CGITEST.ZIP / doscgi.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  2000-05-11  |  3.7 KB  |  164 lines
  1. {  Dos CGI Testing Example provided by Martin Lafferty}
  2.  
  3. {  Should be compiled by Borland/Turbo Pascal comiler for DOS }
  4.  
  5. program Doscgi;
  6. uses
  7.   Strings,
  8.   Dos;
  9.  
  10. var
  11.   UserName: String;
  12.   UserPsw: String;
  13.  
  14.  
  15. procedure ShowError(const ErrorStr: String);
  16. var
  17.   S: string;
  18. begin
  19.   S := 'Error: '+ErrorStr;
  20.  
  21.   Writeln(Output, 'Content-Type: text/html');
  22.   Writeln(Output, '');
  23.   Writeln(Output, '<HTML>');
  24.   Writeln(Output, '<HEAD>');
  25.   Writeln(Output, '<TITLE>Error</TITLE>');
  26.   Writeln(Output, '</HEAD>');
  27.   Writeln(Output, '<BODY>');
  28.   Writeln(Output, '');
  29.   Writeln(Output, '<H1>'+ ErrorStr+ '</H1>');
  30.   Writeln(Output, '<H2>Press BACK button on your browser and fill the form properly');
  31.   Writeln(Output, '');
  32.   Writeln(Output, '</BODY>');
  33.   Writeln(Output, '</HTML>');
  34.  
  35.   Halt;
  36. end;
  37.  
  38.  
  39. function StrToInt(const S: String): Integer;
  40. var
  41.   Result, c : Integer;
  42. begin
  43.   Val(S, Result, C);
  44.   if C <> 0 then Result:= 0;
  45.   StrToInt:= Result
  46. end;
  47.  
  48.  
  49. function UpperCase( const S: String): String;
  50. var
  51.   Result: String;
  52.   i: Integer;
  53. begin
  54.   Result:= S;
  55.   for i:= 1 to Length(Result) do
  56.     Result[i]:= UpCase(Result[i]);
  57.   UpperCase:= Result
  58. end;
  59.  
  60. procedure DecodeParams(P: PChar);
  61.   var J: PChar;
  62.  
  63.   procedure Decode(const S: String);
  64.     var A, K: String;
  65.         I,J: Integer;
  66.   begin
  67.     A := '';
  68.     I := 1; J := 0;
  69.     while (J < 255) and (I <= Length(S)) do
  70.      begin
  71.        Inc(J);
  72.        case S[I] of
  73.          '%': begin
  74.                 A[J] := Char(StrToInt('$'+Copy(S, I+1, 2)));
  75.                 Inc(I, 3);
  76.               end;
  77.          '+': begin A[J] := ' '; Inc(I) end;
  78.             else begin A[J] := S[I]; Inc(I) end;
  79.        end;
  80.      end;
  81.     A[0] := Char(J);
  82.     I := Pos('=', A);
  83.     if I > 0 then
  84.       begin
  85.         K := UpperCase(Copy(A, 1, I-1));
  86.         if K = 'USERID' then UserName := Copy(A, I+1, Length(A)) else
  87.         if K = 'PASSWORD' then UserPsw := Copy(A, I+1, Length(A)) else
  88.         ShowError('Invalid field ' + K);
  89.       end;
  90.   end;
  91.  
  92.  
  93. begin
  94.   UserName := '';
  95.   UserPsw := '';
  96.   repeat
  97.     J:= P;
  98.     while (J^ <> #0) and (J^ <> '&') do
  99.       Inc(J);
  100.     if J^ <> #0 then
  101.     begin
  102.       J^:= #0;
  103.       Decode(StrPas(P));
  104.       P:= J + 1
  105.     end else
  106.     begin
  107.       Break
  108.     end
  109.   until false;
  110.   Decode(StrPas(P));
  111. end;
  112.  
  113. procedure UserOK;
  114. var
  115.   S: string;
  116. begin
  117.   S := 'OK: '+UserName;
  118.  
  119.   Writeln(Output, 'Content-Type: text/html');
  120.   Writeln(Output, '');
  121.   Writeln(Output, '<HTML>');
  122.   Writeln(Output, '<HEAD>');
  123.   Writeln(Output, '<TITLE>You were successfully logged in!</TITLE>');
  124.   Writeln(Output, '</HEAD>');
  125.   Writeln(Output, '<BODY>');
  126.   Writeln(Output, '');
  127.   Writeln(Output, '<H1>Congratulations, '+UserName+'!</H1>');
  128.   Writeln(Output, '<H2>You were successfully logged in!</H2>');
  129.   Writeln(Output, '<H2>It means nothing except TinyWeb CGI does work!</H2>');
  130.   Writeln(Output, '');
  131.   Writeln(Output, '</BODY>');
  132.   Writeln(Output, '</HTML>');
  133.  
  134.   Halt;
  135. end;
  136.  
  137.  
  138.  
  139. procedure ComeOn;
  140. var
  141.   S: String;
  142.   I, J: Integer;
  143.   Variable:string;
  144.   Buffer:array [0..4095] of char;
  145. begin
  146.   Variable:= GetEnv('CONTENT_LENGTH');
  147.   I := StrToInt(Variable);
  148.   if (I <= 0) or (I >= sizeof(Buffer)) then ShowError('Internal script error reading StdIn');
  149.   for j:= 0 to I - 1 do
  150.     Read(Input, Buffer[j]); {slow}
  151.   Buffer[I]:= #0;
  152.   DecodeParams(Buffer);
  153.   if UserName = '' then ShowError('User ID field is blank');
  154.   if UserPsw  = '' then ShowError('Password field is blank');
  155.   if UserName <> 'Jimmi' then ShowError('User ' + UserName + 'is not allowed to log in');
  156.   if UserPsw <> 'Hendrix' then ShowError('Invalid password for user ' + UserName);
  157.   UserOK;
  158. end;
  159.  
  160. begin
  161.   ComeOn
  162. end.
  163.  
  164.